home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
User's Choice Windows CD
/
User's Choice Windows CD (CMS Software)(1993).iso
/
win_m_p
/
pcpwhost.zip
/
HOST1C.COM
/
SUBS.WAS
< prev
Wrap
Text File
|
1992-09-01
|
61KB
|
1,514 lines
;Host Mode v1.00c file - Do not compile!
;***********************************************************************
;* *
;* SUBS.WAS *
;* Copyright (C) 1992 Datastorm Technologies, Inc. *
;* All rights reserverd. *
;* *
;* Purpose: Contains most of the lower level com and file I/O *
;* routines for Host Mode. *
;* *
;***********************************************************************
;***********************************************************************
;* *
;* WARNING!!!! *
;* *
;* Do not modify this script file unless you have a good under- *
;* standing of the Windows ASPECT language. If you do modify this *
;* script, PLEASE MAKE A BACKUP before doing so. *
;* *
;***********************************************************************
;***********************************************************************
;* *
;* HOSTSETUP *
;* *
;* The procedure opens the HOST.PRM file and reads in variables. *
;* Also sets up the paths for the mail files. *
;* *
;* Calls: HOSTMSGBOX, CHECKMENU *
;* *
;* Called by: MAIN *
;* *
;* Modifies globals: sysop, local_logon, parmfile, hdrfile, msgfile, *
;* logfile, usrfile, welcome_msg, upload_path, *
;* dnload_path, new_usr_leve, connect_type, *
;* system_type, goodbye_option, old_menu, new_menu *
;* *
;***********************************************************************
proc HostSetup
sysop=0
local_logon=0
set aspect spawn on
fetch aspect scriptpath parmfile
addfilename parmfile HOSTPRMFILE
fetch aspect scriptpath hdrfile
addfilename hdrfile HOSTHDRFILE
fetch aspect scriptpath msgfile
addfilename msgfile HOSTMSGFILE
fetch aspect scriptpath logfile
addfilename logfile HOSTLOGFILE
fetch aspect scriptpath usrfile
addfilename usrfile HOSTUSRFILE
fetch aspect scriptpath newsfile
addfilename newsfile HOSTNWSFILE
fetch aspect scriptpath nufile
addfilename nufile HOSTNUFILE
fetch aspect scriptpath dnldfile
addfilename dnldfile HOSTDNLDFILE
fetch aspect scriptpath nufile
addfilename nufile HOSTNUFILE
fetch aspect scriptpath logfile
addfilename logfile HOSTLOGFILE
fopen 0 parmfile READ TEXT
if not success
HostMsgBox("FATAL ERROR - Can't open HOST.PRM!")
ExitHost()
endif
fgets 0 welcome_msg
fgets 0 upload_path
fgets 0 dnload_path
fgetc 0 new_usr_level
new_usr_level-=1
fgetc 0 connect_type
connect_type-=1
fgetc 0 system_type
system_type-=1
fgetc 0 goodbye_option
goodbye_option-=1
fclose 0
save_prm()
set aspect control off ; turn off script button
set aspect keys on ; we do all keys
set aspect rxdata on ; we do all incoming data
set terminal enquiry off
set terminal statusline off
set viewgif no ; don't view GIF files
set autodnld off ; Don't autodownload on host
set zmodem errdetect crc32 ; Use 32-bit CRC
set zmodem recvcrash protect ; Don't let users overwrite files
set zmodem sendcrash negotiate ; Let user recover his downloads
set zmodem timestamp off ; Stamp files with system date/time
set zmodem txmethod streaming ; Use fastest transmit method
old_menu=$pwmenubar
menubar new_menu
menuitem new_menu 2 "&Disconnect user!"
showmenu new_menu
disable menu 2
showmenu new_menu
when menu call checkmenu
when userexit call ExitHost
endproc
;***********************************************************************
;* *
;* WAITFORCALL *
;* *
;* This procedure waits for the modem's CD to go high and then gets *
;* the connect message to set the baudrate. *
;* *
;* Calls: HOSTPUTS, EXITHOST *
;* *
;* Called by: MAIN *
;* *
;* Modifies globals: connect_type, welcome_msg, tempkey, _time, _date, *
;* name, ontime, offtime, status, local_logon, sysop *
;* *
;* Notes: If connection is a direct connect it puts out the welcome *
;* message and returns. *
;* *
;***********************************************************************
proc WaitForCall
string c300, c1200, c2400, c4800, c9600, c19200, c38400, c57600
string modemmsg=""
integer char, index=0
string auto_ans_on
integer adjustbaud
long ltime, modem_speed
fetch modem cnct300 c300
strreplace c300 "^M" "`r" ; replace ^M with a real CR
fetch modem cnct1200 c1200
fetch modem cnct2400 c2400
fetch modem cnct4800 c4800
fetch modem cnct9600 c9600
fetch modem cnct19200 c19200
fetch modem cnct38400 c38400
fetch modem cnct57600 c57600
fetch modem autobaud adjustbaud
clear ; clear screen
if connect_type==DIRECT_CON ; check for DIRECT connect
rxflush ; flush receive buffer
HostPutS("`r`n")
HostPutS(welcome_msg) ; display welcome message
HostPutS("`r`n`r`n")
return
endif
fetch modem baudrate modem_speed
fetch modem autobaud adjustbaud ; find out if modem's autobaud is on
fetch modem autoanson auto_ans_on ; get modem auto answer string
if $CARRIER ; if CD is high try to hangup
sdlgmsgbox "Host Message" "The modem is reporting `"ONLINE`".`n`nStart Host Mode script anyway?" STOP YESNO tempkey 2 beep
if tempkey==7
ExitHost()
endif
endif
rxflush ; flush receive buffer
set aspect rxdata on ; aspect will process all incoming data
if ! $CARRIER
dialogbox 42 25 200 70 14 "Host Mode"
text 13 25 166 8 center "Initializing Modem ...... Please Wait."
enddialog
set txpace 50
set baudrate modem_speed
transmit "~^M~"
txflush
rxflush
transmit auto_ans_on
if not waitfor "OK" 5
statmsg "Modem did not respond `"OK`" to Auto Answer command."
endif
set txpace 0
destroydlg ; get rid of dialog box
_time=$TIME ; get current date and time
_date=$DATE
strcmp name "" ; see if there was a
if success ; previous caller
name = "None"
endif
dialogbox 48 4 162 172 14 "Host Mode - Waiting for call"
vtext 25 100 49 9 left _time
text 13 24 40 8 left "Last Caller: "
vtext 56 24 83 9 left name
vtext 82 100 42 9 left _date
groupbox 15 87 124 32 "Current" shadow
text 21 44 34 8 left "Online at: "
text 22 60 38 8 left "Offline at: "
vtext 76 44 39 9 left ontime
vtext 77 60 39 9 left offtime
pushbutton 16 135 54 14 "E&xit" update
pushbutton 80 135 54 14 "&Local Logon" update
groupbox 6 8 143 70 "Statistics" shadow
enddialog
status=$DIALOG ; dialog box status
while 1
ltime=$LTIME
_time=$TIME
_date=$DATE
if $carrier ; loop until CD goes high
exitwhile
endif
if $KEYHIT
keyget tempkey
if tempkey==0x409 ; ALT-TAB ; these special keys must be
termvkey 0x409
endif
endif
switch status
case 30
ExitHost()
endcase
case 31
local_logon=TRUE
connect_type=DIRECT_CON
sdlgmsgbox "Host Message" "Do you want to logon as SYSOP?" QUESTION YESNO tempkey 1 beep
if tempkey==6
sysop=TRUE
endif
HostPutS("`r`n`r`n")
HostPutS(welcome_msg) ; display welcome message
HostPutS("`r`n")
destroydlg
return
endcase
endswitch
status=$DIALOG
if ltime<$LTIME ; see if time has passed
updatedlg 64 ; if it has update the dialog box
endif
endwhile
statmsg " "
destroydlg ; remove dialog box
if adjustbaud ; if autobaud detect if on
ltime=$LTIME ; get current time
ltime+=25 ; wait for 25 seconds for a modem message
while 1 ; loop and parse modem message
if $LTIME >= ltime ; if 25 seconds have passed, exit loop
statmsg "No matching connect message!" BEEP
exitwhile
endif
if ! $RXCOUNT ; if there are no characters
loopwhile ; in the buffer then loop
endif
comgetc char ; get a characters
if char==-1 ; if there is not a character
loopwhile ; then loop
endif
strpoke modemmsg index char ; insert a character
index++ ; increment index
if index == 254
statmsg "No matching connect message!" BEEP
exitwhile
endif
if strfind modemmsg c300 ; search for connect messages
statmsg "CONNECT 300" ; this is ugly, but there's no
set baudrate 300 ; other way to do it.
exitwhile
elseif strfind modemmsg c1200
statmsg "CONNECT 1200"
set baudrate 1200
exitwhile
elseif strfind modemmsg c2400
statmsg "CONNECT 2400"
set baudrate 2400
exitwhile
elseif strfind modemmsg c4800
statmsg "CONNECT 4800"
set baudrate 4800
exitwhile
elseif strfind modemmsg c9600
statmsg "%s" modemmsg
statmsg "CONNECT 9600"
set baudrate 9600
exitwhile
elseif strfind modemmsg c19200
statmsg "CONNECT 19200"
set baudrate 19200
exitwhile
elseif strfind modemmsg c38400
statmsg "CONNECT 38400"
set baudrate 38400
exitwhile
elseif strfind modemmsg c57600
statmsg "CONNECT 57600"
set baudrate 57600
exitwhile
endif
endwhile
else
statmsg "Connected!"
endif
endif
pause 1 ; pause a moment, then flush the
rxflush ; buffers to remove any wierd modem
txflush ; message or handshake characters
HostPutS("`r`n`r`n")
HostPutS(welcome_msg) ; display welcome message
HostPutS("`r`n")
endproc
;***********************************************************************
;* *
;* GETUSER *
;* *
;* This procedure prompts a user to login. *
;* *
;* *
;* Calls: XKEYGET, HOSTLOG, SETFAILURE, GETUSERNAME, GETUSERPSWD, *
;* PARSEUSRREC, SETSUCCESS *
;* *
;* Modifies globals: tempkey, connect_type, ontime *
;* *
;***********************************************************************
proc GetUser
while 1
if $keyhit
XKeyGet(&tempkey)
endif
if (! $carrier) && (connect_type==MODEM_CON)
HostLog("Lost Carrier", "")
SetFailure()
return
endif
GetUserName() ; Get the users name
if success
GetUserPswd() ; Get the users password
if success
ParseUsrRec() ; strfind and parse user record
if success ; If found and parsed
time ontime ; get current time
SetSuccess()
return
else
SetFailure() ; Error getting user record
return
endif
else
SetFailure() ; Error getting password
return
endif
else ; Error getting user name
SetFailure()
return
endif
endwhile
endproc
;***********************************************************************
;* *
;* GETUSERNAME *
;* *
;* This procedure get the first and last name from the remote user. *
;* *
;* *
;* Calls: HOSTLOG, SETFAILURE, HOSTPUTS, HOSTGETS, HOSTGETYN, *
;* HOSTHANGUP *
;* *
;* Modifies globals: connect_type, first, last, name *
;* *
;***********************************************************************
proc GetUserName
integer i, len, tries
tries = 0
if (! $carrier) && (connect_type==MODEM_CON)
HostLog("Lost Carrier", "")
SetFailure()
return
endif
pause 1
rxflush
while tries < 3
tries++
HostPutS("`r`n`r`nFirst name: ")
HostGetS(&first, NAMEMAX, DISP) ; Get first (and optionally last)
if not success ; return FAILURE if CD drops
exitwhile
endif
strlen first len ; len = length of first name
if len == 0 ; If length is zero
loopwhile ; go to top of loop
endif
strfind first " " i ; Is there a last name? (SPACE)
if not found
strfind first ";" i ; (Look for SEMICOLON if no SPACE)
endif
if found ; YES, there is a last name:
strpoke first i 0 ; terminate the first name
i++ ; i -> 1st character in last name
substr last first i 80 ; ulast is last name
else
HostPutS("`r`nLast name: ")
HostGetS(&last, NAMEMAX, DISP) ; Get last name
if not success
exitwhile
endif
strlen last len
if len == 0
loopwhile
endif
endif
strupr first
strupr last
name = first
strcmp last ""
if not success
strcat name " "
strcat name last
endif
HostPutS("`r`n")
HostPutS(name)
HostPutS("`r`nIs this correct (Y/N)? ")
HostGetYN()
if success
return
else ; if user says NO
tries-- ; don't count it as a try
endif
endwhile
if connect_type==MODEM_CON
HostHangup()
endif
HostLog("unknown caller", "failed to enter name.")
SetFailure()
endproc
;***********************************************************************
;* *
;* GETUSERPSWD *
;* *
;* This procedure get the users password. *
;* *
;* *
;* Calls: HOSTPUTS, HOSTLOG, SETFAILURE, HOSTGETS, SETSUCCESS, *
;* HOSTHANGUP *
;* *
;* Modifies globals: connect_type, passwrd, name *
;* *
;***********************************************************************
proc GetUserPswd
integer i, tries
tries = 0
HostPutS("`r`n")
while tries < 3
if (! $carrier) && (connect_type==MODEM_CON)
HostLog("Lost Carrier", "")
SetFailure()
return
endif
HostPutS("`r`nPassword: ")
HostGetS(&passwrd, PSWDMAX, MASK) ; Get passwrd
if not success
exitwhile
endif
strlen passwrd i
if i > 0
strupr passwrd
SetSuccess()
return
endif
tries++
endwhile
if connect_type==MODEM_CON
HostHangup()
endif
HostLog(name, "failed to enter password.")
SetFailure()
endproc
;***********************************************************************
;* *
;* HOSTGETS *
;* *
;* This procedure gets a string from the remote user. *
;* *
;* *
;* Calls: HOSTGETC, SETSUCCESS, HOSTPUTS *
;* *
;* Modifies globals: none *
;* *
;***********************************************************************
proc HostGetS
strparm s
intparm max, dodisp
integer i
string response
strpoke s 0 0
i = 0
while 1
HostGetC(&response)
if not success
exitwhile
endif
switch response
case "`r"
SetSuccess()
exitwhile
endcase
case "`b"
if i != 0
HostPutS(response)
i--
strpoke s i 0
endif
endcase
case " " ; This SPACE case must immediately
if i == 0 ; precede the default so it will
loopwhile ; fall through
endif
default
if i < max
if dodisp
HostPutS(response)
else
HostPutS("*")
endif
strcat s response
i++
endif
endcase
endswitch
endwhile
endproc
;***********************************************************************
;* *
;* HOSTGETYN *
;* *
;* This procedure get a Y or N from the remote user. *
;* *
;* *
;* Calls: HOSTGETC, HOSTPUTS, SETSUCCESS, SETFAILURE *
;* *
;* Modifies globals: none *
;* *
;***********************************************************************
proc HostGetYN
string response
while 1
HostGetC(&response)
if not success
return
endif
strupr response
HostPutS(response)
switch response
case "Y"
SetSuccess()
return
endcase
case "N"
default
SetFailure()
return
endcase
endswitch
endwhile
endproc
;***********************************************************************
;* *
;* HOSTGETC *
;* *
;* This procedure gets a character from the remote user. *
;* *
;* *
;* Calls: XKEYGET, HOSTLOG, SETFAILURE, SETSUCCESS *
;* *
;* Modifies globals: local_logon, connect_type *
;* *
;***********************************************************************
proc HostGetC
strparm c
integer i = -1
while i == -1
if $keyhit ; If a key is pressed
XKeyGet(&i) ; get the key
endif
if !local_logon
if $RXDATA ; If data available at port
comgetc i ; get the next character
endif
if (! $carrier) && (connect_type==MODEM_CON) ; If carrier drops
HostLog("Lost Carrier", "")
SetFailure() ; set error return code
return ; and return to caller
endif
endif
endwhile
strfmt c "%c" i
SetSuccess()
endproc
;***********************************************************************
;* *
;* HOSTPUTS *
;* *
;* This procedure send a string to the remote user and displays it *
;* in the terminal window. *
;* *
;* Calls: NONE *
;* *
;* Called by: EVERYTHING!! 168 times *
;* *
;* Modifies globals: local_logon *
;* *
;***********************************************************************
proc HostPutS
strparm s
if !local_logon
transmit s ; send the string to the remote user
endif
termwrites s ; send the string to the local screen
endproc
;***********************************************************************
;* *
;* PARSEUSRREC *
;* *
;* This procedure looks up a user in .USR file and parse record *
;* into globals. *
;* *
;* *
;* Calls: ADDUSER, COPYSFLD, SETSUCCESS, GETUSERPSWD, HOSTPUTS, *
;* HOSTHANGUP, HOSTLOG, SETFAILURE, HOSTMSGBOX *
;* *
;* Modifies globals: name, first, last, passwrd, usrfile, record, *
;* access_level, remarks, connect_type, system_type *
;* *
;* NOTES: *
;* access_level - User's access level ("0", "1", or "2") *
;* comment - User's comment field *
;* first - User's first name *
;* last - User's last name *
;* name - User's full name (first and last) *
;* passwrd - User's password *
;* record - Raw record (terminated with a line feed) *
;* *
;* HOSTS.USR record: *
;* *
;* lastname;firstname;passwrd;n;comment....... *
;* (n is the access_level level {'0','1',or '2'}) *
;* *
;***********************************************************************
proc ParseUsrRec
integer i, tries=1
string tmp, tmp1, tmp2, tmp3
strfind name " " i ; i = index of blank name separator
if found
strcpy first name i ; copy first name
i++ ; i = index of last name
substr last name i 79 ; extract last name
endif
strfmt tmp "%s;%s" last first ; 'tmp' is what we're looking for
strfmt tmp2 "%s;%s;%s" last first passwrd
strlen tmp i ; i = length of name part
isfile usrfile
if not success
AddUser()
return
else
fopen 1 usrfile READ TEXT ; Try to open user file
endif
if success ; If opened
while not FEOF 1 ; loop until end of file
fgets 1 record ; Get record
strupr record ; upper case the record
strcmp record tmp i ; Scan record for user
if success ; If this is our guy,
while tries<3
strextract tmp3 record ";" 2
strfmt tmp1 "%s;%s" tmp tmp3
strlen tmp1 i
strcmp record tmp2 i
if success
; Copy password
CopySFld(&passwrd, record, &i, FLD_SEP)
; Copy access level level
CopySFld(&access_level, record, &i, FLD_SEP)
; Copy comment
CopySFld(&remarks, record, &i, FLD_SEP)
SetSuccess()
return
else
GetUserPswd()
if success
strfmt tmp2 "%s;%s;%s" last first passwrd
endif
tries++
endif
endwhile
HostPutS("`r`n`r`nPassword incorrect.`r`n")
if connect_type==MODEM_CON
HostHangup()
endif
HostLog(name, "failed password check.")
SetFailure()
return
endif
endwhile
fclose 1
if system_type==CLOSED_SYSTEM
HostPutS("`r`nSorry, this is a closed system.`r`n")
if connect_type==MODEM_CON
HostHangup();
endif
HostLog(name, "attempted to login to closed system.")
SetFailure()
return
endif
AddUser()
return
else
HostMsgBox("ERROR - Can't open HOST.USR file!")
endif
SetFailure()
endproc
;***********************************************************************
;* *
;* COPYSFLD *
;* *
;* This procedure will copy a string field (SFLD) from any position *
;* within the source string, to the destination string. Also, it *
;* will increment the index by the length of the field copied. *
;* *
;* Calls: NONE *
;* *
;* Modifies globals: none *
;* *
;* NOTES: *
;* Input: (&destination,source,&index,field_separator) *
;* *
;* Return: destination and int are updated. *
;* *
;* Notes: Terminates when a field_separator or line feed is *
;* encountered. If neither is encountered, the rest of the *
;* field is copied. *
;* *
;***********************************************************************
proc CopySFld
strparm dst
strparm src
intparm index
intparm fldsep
integer newidx
string endstr,tmp
substr endstr src index 79 ; copy end of string to local var
strfmt tmp "%c" fldsep ; tmp = field separator as a string
strfind endstr tmp newidx ; see if a separator is in the string
if not found ; If separator not found:
strfind endstr "\n" newidx ; is a line feed in the string?
if not found ; If not:
strlen endstr newidx ; use the whole string
endif
endif
strcpy dst endstr newidx ; copy field
index = index + newidx + 1 ; set caller's index
endproc
;***********************************************************************
;* *
;* HOSTHANGUP *
;* *
;* This procedure attempts to hangup the line several times. *
;* *
;* *
;* Calls: HOSTPUTS, TXWAIT *
;* *
;* Modifies globals: none *
;* *
;***********************************************************************
proc HostHangup
integer hanguptries=3
while $TXCOUNT>0 ; wait for tx buffer to clear
endwhile
if not $carrier
return
endif
while hanguptries--
pause 1
hangup
if not $carrier
exitwhile
endif
endwhile
if $carrier
HostPutS ("`r`nERROR - Unable to hangup.`r`n")
endif
endproc
;***********************************************************************
;* *
;* SETFAILURE *
;* *
;* This procedure sets the IF FAILURE flag to TRUE. *
;* *
;* *
;* Calls: NONE *
;* *
;* Modifies globals: none *
;* *
;***********************************************************************
proc SetFailure
strcmp "X" "Y" ; compare is always FALSE
endproc
;***********************************************************************
;* *
;* SETSUCCESS *
;* *
;* This procedure sets the IF SUCCESS flag to TRUE. *
;* *
;* *
;* Calls: NONE *
;* *
;* Modifies globals: none *
;* *
;***********************************************************************
proc SetSuccess
strcmp "X" "X" ; compare is always TRUE
endproc
;***********************************************************************
;* *
;* XKEYGET *
;* *
;* This procedure processes local keystrokes. *
;* *
;* *
;* Calls: EXITHOST, HOSTHANGUP *
;* *
;* Modifies globals: none *
;* *
;***********************************************************************
proc xkeyget
intparm key
integer real_key
keyget key ; get the key value
switch key
case 0x409 ; ALT-TAB ; these special keys must be
case 0x14 ; CAPS LOCK ; must be passed to the
case 0x890 ; NUM LOCK ; main window to be recognized
termkey key
key=0x00
endcase
case 0x458 ; E&xit Host
case 0x558
ExitHost()
endcase
case 0x444
case 0x544 ; &Disconnect User
HostHangup()
longjmp 1 1
endcase
case 0x452
case 0x552
longjmp 1 1 ; &Recycle host
endcase
default
keytoascii key real_key ; convert virtual key into
key=real_key ; ASCII value for return
endcase
endswitch
endproc
;***********************************************************************
;* *
;* GETNEWPSWD *
;* *
;* This procedure gets the password for a new user. *
;* *
;* *
;* Calls: HOSTPUTS, HOSTGETS, SETSUCCESS, HOSTHANGUP, HOSTLOG, *
;* SETFAILURE *
;* *
;* Modifies globals: passwrd, connect_type, name *
;* *
;***********************************************************************
proc GetNewPswd
integer i, tries
string newpswd
tries = 0
HostPutS("`r`n")
while tries < 3
HostPutS("`r`nPlease verify: ")
HostGetS(&newpswd, PSWDMAX, MASK) ; Get passwrd
if not success
exitwhile
endif
strlen passwrd i
if i > 0
strupr passwrd
strupr newpswd
strcmp passwrd newpswd
if success
SetSuccess()
return
endif
endif
tries++
endwhile
if connect_type==MODEM_CON
HostHangup()
endif
HostLog(name, "failed to verify password.")
SetFailure()
endproc
;***********************************************************************
;* *
;* ADDUSER *
;* *
;* This procedure adds a new user the the HOST.USR file. *
;* *
;* Calls: GETNEWPSWD, HOSTMSGBOX, DISPLAYFILE, HOSTLOG, SETSUCCESS, *
;* SETFAILURE *
;* *
;* Modifies globals: usrfile, record, last, first, passwrd, *
;* new_usr_level, access_level, name *
;* *
;***********************************************************************
proc AddUser
GetNewPswd()
if success
isfile usrfile
if not success
fopen 1 usrfile CREATE TEXT
if not success
HostMsgBox("ERROR - Can't create HOST.USR file!")
ExitHost()
endif
else
fopen 1 usrfile WRITE TEXT
if not success
HostMsgBox("ERROR - Can't open HOST.USR file!")
ExitHost()
endif
fseek 1 0 2 ; go to end of file
endif
strfmt record "%s;%s;%s;%i;* NEW USER *" last first passwrd new_usr_level
itoa new_usr_level access_level
fputs 1 record
if not success
HostMsgBox("ERROR - Didn't write user info!")
endif
fclose 1
DisplayFile(nufile, 23)
HostLog(name, "first login - added to user file.")
SetSuccess()
return
endif
SetFailure()
endproc
;***********************************************************************
;* *
;* CHECKMENU *
;* *
;* This procedure processes menu selections made with the mouse. *
;* *
;* *
;* Calls: HOSTHANGUP, EXITHOST *
;* *
;* Called by: WHEN MENU command *
;* *
;* Modifies globals: status *
;* *
;***********************************************************************
proc CheckMenu
status=$MENU
switch status
case 2 ; 2 is &Disconnect remote
HostHangup()
longjmp 1 1
endcase
case 3
longjmp 1 1 ; 3 &Recycle host
endcase
case 4
ExitHost()
endcase
endswitch
endproc
;***********************************************************************
;* *
;* EXITHOST *
;* *
;* This procedure allows safe shutdown of Host Mode script. *
;* *
;* *
;* Calls: HOSTHANGUP, HOSTMSGBOX, HOSTLOG, RESTORE_PRM *
;* *
;* Modifies globals: connect_type, action_status, meta_status, *
;* dial_status, setup_status *
;* *
;***********************************************************************
proc ExitHost
string auto_ans_off
integer response
if (connect_type==MODEM_CON) || (local_logon==TRUE)
rxflush
txflush
transmit "^M"
statmsg "Closing Host Mode ..." BEEP
set txpace 50
if $CARRIER
sdlgmsgbox "Host Message" "Hangup Line?" QUESTION YESNO response 2 BEEP
if response==6
HostHangup()
fetch modem autoansoff auto_ans_off
pause 1
transmit auto_ans_off
waitfor "OK" 8
endif
else
fetch modem autoansoff auto_ans_off
pause 1
transmit auto_ans_off
waitfor "OK" 8
endif
endif
HostMsgBox("Host Mode aborted")
HostLog("Host mode offline.", "")
restore_prm()
if action_status
actionbar on
endif
if meta_status
metakeys on
endif
if dial_status
dialdir on
endif
if setup_status
setup on
endif
statmsg " "
pwtitlebar "PROCOMM PLUS for Windows"
clear
halt
endproc
;***********************************************************************
;* *
;* DISPLAYFILE *
;* *
;* This procedure sends an ASCII file to the remote user with paging. *
;* *
;* *
;* Calls: SETFAILURE, HOSTPUTS, HOSTGETC, SETSUCCESS *
;* *
;* Modifies globals: none *
;* *
;***********************************************************************
proc DisplayFile
strparm _file ; file to transmit
intparm page_length ; how many lines before -MORE- prompt
string line, response
integer count=0
isfile _file ; check for the file
if not success ; if it doesn't exist
SetFailure() ; return
return
endif
fopen 5 _file READ ; open the file
while 1 ; loop forever
if not $CARRIER
fclose 5
SetFailure()
return
endif
fgets 5 line ; get a line
if FEOF 5 ; check for EOF
exitwhile
endif
HostPutS(line) ; display line
inc count ; increment line counter
if count==page_length ; if count == page length display a prompt
HostPutS("-MORE-")
HostGetC(&response) ; get user input
HostPutS("`b`b`b`b`b`b")
strupr response
strcmp response "N" ; if the user says NO then
if success
exitwhile
endif
count=1 ; reset line counter
endif
endwhile
fclose 5 ; close the file
SetSuccess()
endproc
;***********************************************************************
;* *
;* HOSTMSGBOX *
;* *
;* This procedure displays a dialog box with an error message for *
;* 3 seconds. *
;* *
;* Calls: NONE *
;* *
;* Modifies globals: message *
;* *
;***********************************************************************
proc HostMsgBox
strparm _message
beep
beep
mspause 500
dialogbox 48 20 174 65 15 "Host Mode Message"
vtext 1 16 167 26 center message
enddialog
message=_message
updatedlg -1
pause 2
destroydlg
endproc
;***********************************************************************
;* *
;* CHAT *
;* *
;* This procedure allows the sysop and a remote user to converse *
;* online. *
;* *
;* *
;* Calls: HOSTPUTS, HOSTGETC, SETFAILURE *
;* *
;* Modifies globals: msg, name, status *
;* *
;***********************************************************************
proc Chat
string c
long timer
HostPutS("`r`nPaging Host Operator ...`r`n")
strfmt msg "Remote user %s is requesting to chat." name
dialogbox 26 22 200 67 13
pushbutton 59 38 76 14 "OK" normal default
vtext 9 13 178 9 center msg
enddialog
status=$DIALOG
alarm
alarm
timer=$LTIME
while ($LTIME < (timer+8))
if status==10
destroydlg
HostPutS("`r`nHost Operator is online!`r`n`r`n")
HostPutS("Press ESC to end chat.`r`n`r`n")
while 1
HostGetC(&c)
if failure
SetFailure()
return
endif
switch c
case "`r"
strcat c "`n"
endcase
case "`x1b"
return
endcase
endswitch
transmit c
termwrites c
endwhile
endif
status=$DIALOG
endwhile
destroydlg
HostPutS("`r`nHost Operator is not available!`r`n")
endproc
;***********************************************************************
;* *
;* COUNTMSG *
;* *
;* This procedure counts the number of mail messages. *
;* *
;* *
;* Calls: HOSTMSGBOX, EXITHOST *
;* *
;* Modifies globals: hdrfile *
;* *
;***********************************************************************
proc CountMsg
intparm number
integer dummy
string msg_entry
number=0 ; start with 0 messages
isfile hdrfile ; is HOST.HDR present
if not success ; if not return
return
endif
fopen 4 hdrfile READ ; open HOST.HDR
if not success ; error opening the file
HostMsgBox("FATAL ERROR - Can't open HOST.HDR file!")
ExitHost() ; exit script
endif
while 1 ; loop forever
fread 4 msg_entry 128 dummy ; read 1 message entry
if FEOF 4 ; if EOF, close file and return
fclose 4
return
endif
inc number ; otherwise add 1 to message count
endwhile
endproc
;***********************************************************************
;* *
;* MAILGETLINE *
;* *
;* This procedure accepts a string from the user for entering mail. *
;* *
;* *
;* Calls: HOSTGETC, SETSUCCESS, HOSTPUTS *
;* *
;* Modifies globals: none *
;* *
;***********************************************************************
proc MailGetLine
strparm s
integer max=70
integer i
string response
strpoke s 0 0
i = 0
while 1
HostGetC(&response)
if not success
SetFailure()
return
endif
switch response
case "`r"
SetSuccess()
exitwhile
endcase
case "`b"
if i != 0
HostPutS(response)
i--
strpoke s i 0
endif
endcase
case " " ; This SPACE case must immediately
if i>55 ; precede the DEFAULT so it will
i=max ; fall through
endif ; do wordwrap stuff here!!!
default
if i == max
HostPutS(response)
strcat s response
SetSuccess()
exitwhile
else
HostPutS(response)
strcat s response
i++
endif
endcase
endswitch
endwhile
endproc
;***********************************************************************
;* *
;* CHECKMAIL *
;* *
;* This procedure notifies a user that there is new mail waiting. *
;* *
;* *
;* Calls: HOSTPUTS *
;* *
;* Modifies globals: hdrfile, _date, _time, name *
;* *
;***********************************************************************
proc CheckMail
integer msg_num, msg_length, msg_flag, dummy
string destination, from, subject
long offset
isfile hdrfile ; is HOST.HDR present
if not success ; if not return
return
endif
fopen 0 hdrfile READ ; open HOST.HDR for read only
if not success ; error opening file
return
endif
while 1 ; loop forever
fgeti 0 msg_num ; get the message number
if FEOF 0 ; if EOF exit the while loop
exitwhile
endif
fgetl 0 offset ; get message file offset
fgeti 0 msg_length ; get length of message
fgetc 0 msg_flag ; get message flag
fread 0 destination 31 dummy ; get TO:
fread 0 from 31 dummy ; get FROM:
fread 0 subject 37 dummy ; get subject
fread 0 _date 9 dummy ; get message date
fread 0 _time 11 dummy ; get message time
strcmp destination name ; compare message TO: and user name
if success ; if this is there message
if (msg_flag & 2)==NEWMAIL ; check to see if NEWMAIL flag is set
HostPutS("`r`n`aYou have mail waiting!`r`n`r`n")
exitwhile ; leave the while loop
endif
endif
endwhile
fclose 0 ; close HOST.HDR
endproc
;***********************************************************************
;* *
;* CHANGEFLAG *
;* *
;* This procedure modifies the flag byte for a message. *
;* *
;* *
;* Calls: NONE *
;* *
;* Modifies globals: hdrfile, msg_number *
;* *
;***********************************************************************
proc ChangeFlag
intparm flagbyte
long hdr_offset
fopen 0 hdrfile WRITE ; open HOST.HDR as write only
if not success ; error opening file
return
endif
hdr_offset=((msg_number-1)*128)+8
fseek 0 hdr_offset 0 ; seek to flag byte of current message
fputc 0 flagbyte ; write the passed parameter
fclose 0 ; close HOST.HDR
endproc
;***********************************************************************
;* *
;* DELETEMSG *
;* *
;* This procedure marks a mial message for deletion. *
;* *
;* *
;* Calls: HOSTMSGBOX, HOSTPUTS, CHANGEFLAG *
;* *
;* Modifies globals: hdrfile, msg_number, _date, _time, name, *
;* access_level *
;* *
;***********************************************************************
proc DeleteMsg
integer msg_num, msg_length, msg_flag, dummy
long offset, hdr_offset
string destination, from, subject
isfile hdrfile
if not success
return
endif
fopen 0 hdrfile READ
if not success
HostMsgBox("Can't open HDRFILE - Proc DeleteMsg")
return
endif
hdr_offset=(msg_number-1)*128
fseek 0 hdr_offset 0
fgeti 0 msg_num
if FEOF 0
fclose 0
return
endif
fgetl 0 offset ; get message file offset
fgeti 0 msg_length ; get length of message
fgetc 0 msg_flag ; get message flag
fread 0 destination 31 dummy ; get TO:
fread 0 from 31 dummy ; get FROM:
fread 0 subject 37 dummy ; get subject
fread 0 _date 9 dummy ; get message date
fread 0 _time 11 dummy ; get message time
strcmp destination name ; compare message TO: and user name
if not success
strcmp from name ; compare message FROM: and user name
if not success
strcmp access_level "2" ; is this user a level 2 security
if not success ; if not send message and return
HostPutS("`r`nYou can't delete this message.`r`n")
return
endif
endif
endif
fclose 0 ; close HOST.HDR
msg_flag=msg_flag+4 ; add DELETED flag to the flag byte
ChangeFlag(msg_flag) ; pass new message flag to ChangeFlag
HostPutS("`r`nMessage has been marked for deletion.`r`n`r`n")
endproc
;***********************************************************************
;* *
;* TXWAIT *
;* *
;* This procedure waits for the TX buffer to empty before returning. *
;* *
;* *
;* Calls: NONE *
;* *
;* Modifies globals: none *
;* *
;***********************************************************************
proc txwait
while $TXCOUNT>0
endwhile
pause 3
endproc
;**** End of SUBS.WAS ****
